perm filename LLL[NEW,LCS]1 blob
sn#310952 filedate 1977-10-19 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE PT2
C00020 ENDMK
Cā;
SUBROUTINE PT2
DIMENSION BARS(1),JBAR(1),JRN(1),MBAR(1),JTRN(1),PGTRN(1)
COMMON /FIN/LBAR,METR,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /MNX/MIN,MAX,JT
COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK(0/7),
1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7) /RSIG/RSIG(0/7)
1 /KBAR/KBAR(1) /RSP/KNM(10),ENDLN,N,NAME,NMPG,T
COMMON RS,JA,RA,R,RB,RQ(15),KQ,NQ,JQ,JJQ,KBQ,NAQ /KNUM/KNUM
1 /STF/RSTFAC(0/7),RSTJ2 /IVV/IV(1) /SIZE/SIZE /ITX/ITX(18)
COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,ITRANS,I,RXQ,XSIG
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(50)
1/BRJ/JTOT,TRN
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5)),(KT,KBAR)
1,(R8,RQ(6)),(R9,RQ(7)),(JRN,RN),(MBAR,RN(1000)),(KA,KBAR(1025))
1,(K,KBAR(1027)),(JTRN,Q),(J,KBAR(1026)),(PGTRN,KBAR(516))
1,(LCNT,IV(45)),(NDPY,IV(46)),(TOT,KBAR(2)),(JBAR,BARS,KBAR(4))
DATA JLINE/250/,HX/2./,ITX/'EF-','E-','F','GF','G','AF','A',
1 'BF','B',0,'DF','D','EF','E','F+','BBF','O-','O+'/,
1 SLSP/11.0/,DIV/4./
INTEGER DSK
C O- = OCTAVE DOWN, O+ =OCTAVE UP. OR 1/2 STEP NUMS. MAY BE USED.
C JLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
C TRNSP'S ALL
145 FORMAT(F,3I)
IF(NAMX.NE.0)GO TO 2000
CALL GETEXT('BARS','PAG')
CALL EXTIN(KBAR,1024)
C STAFF NAMES BEGIN IN KBAR(508) [STFNM(0)7]
CALL EXTIN(RSTFAC,128)
2000 TYPE 144,RSTJ2
144 FORMAT(' STAFF SIZE='F4.2,' CHANGE TO '$)
ACCEPT 145,SIZE,DSK
C TYPE 2ND NUM TO WRITE BARS/LINE DATA ON DSK FILE FOR21.DAT
IF(DSK.NE.0)DSK=-1
XSIG=0
IF(IPG)GO TO 2001
C IF NOT PARTS, INDICATE 1ST PAGE NUM (TO START PAGE NUMS BEYOND 1)
TYPE 2002
2002 FORMAT(' FIRST PAGE NUMBER -- '$)
306 FORMAT(I5,3X8I5)
ACCEPT 306,KNUM
2001 TYPE 304
304 FORMAT(' TRANSP.= '$)
ACCEPT 2101,ITRANS
IF(ITRANS.GT.-20)GO TO 1101
2101 FORMAT(A3)
C NEXT FOR LETTER NAMES
DO 3101 K=1,18
3101 IF(ITRANS.EQ.ITX(K))GO TO 4101
5101 TYPE 240
GO TO 2000
240 FORMAT(' THIS TRANSP NOT OFFERED')
1101 REREAD 306,ITRANS
IF(ITRANS.EQ.0)GO TO 1304
ITRANS=10-ITRANS
IF(ITRANS.EQ.22)ITRANS=17
C FOR DOWN OCT.
IF(ITRANS.GT.0)GO TO 1304
IF(ITRANS.EQ.-2)ITRANS=18
C -2 NOW = UP OCT.
GO TO 1304
4101 ITRANS=K
1304 IF(SIZE.EQ.0)SIZE=RSTJ2
SIZE=SIZE/RSTJ2
TYPE 2003
2003 FORMAT(' TYPE PAGE TURN TIME (.5=1/8 REST, 1=1/4 REST, ETC.)--'$)
ACCEPT 145,TRN
IF(TRN.EQ.0)TRN=100.
101 JTOT=0
ITOT=0
CXX BARS(1)=BARS(1)-5.0
C ABOVE ASSUMES FIRST LINE ALWAYS HAS A CLEF.
122 DO 22 K=1,KT
JJ=BARS(K)*SIZE+.5
ITOT=ITOT+JJ
JBAR(K)=JJ
22 JTOT=JTOT+JJ
ITOT=TOT*SIZE
CC22 JBAR(K)=BARS(K)*SIZE+.5
CC TOT=TOT*SIZE
33 IF(RSTJ2.EQ.0)RSTJ2=1
RA=JPG*SIZE*RSTJ2
MPG=10./RA
C MPG=NUM OF BRACES PER PAGE.
RS=SIZE*17
RA=(RSTJ2*SIZE)/RPSZ(1)
DO 141 K=1,JPG
RB=RSTNUM(K)-1
C ADJUSTS DIST. BETWEEN STAVES DEPENDING ON SIZE FACTOR.
RHGT(K)=RHGT(K)+RB*(RS-17)
141 RPSZ(K)=RPSZ(K)*RA
LPG=JPG
140 TYPE 90,KT
RA=0
90 FORMAT(' TOTAL BAR LINES='I3/' NUMBER OF BARS PER LINE')
JT=ITOT/JLINE
C USE JLINE (250 FOR NOW) AS SUGGESTED LINE LENGTH
16 CALL BRJUGL(JT,JBAR(1),KT,NBAR(1),MBAR(1),JRN(1),PGTRN(1)
1,JTRN(1))
NBAR(JT+1)=0
RPG=JT
RPG=RPG/MPG
605 TYPE 604,RPG,JT
IF(DSK)WRITE(21,604)RPG,JT
604 FORMAT(F5.2,' PAGES',/,I4,' LINES - OR TYPE N1, N2 --'$)
C FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
KA=0
K=JT
C FOR 'T' TYPE X.Y FOR X PAGES, Y LINES PER PAGE.( .05=5 LINES, .10=10 ETC.)
ACCEPT 145,T,N,KL
C TYPE 0,n TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
IF(KL.NE.0)GO TO 110
C NO MORE THAN 50 NUMS, INCLUDING 0S (FOR PAGE MARKS)
IF(T.EQ.0)GO TO 11
JT=T
IF(T.EQ.JT)GO TO 210
MPG=(T-JT)*100.+.5
C MPG=LINES PER PAGE, JT=TOTAL NUM OF BARS
JT=JT*MPG
IF(JT.LE.KT)GO TO 210
C CATCHES REQUEST FOR TOO MANY BARS.
JT=K
GO TO 605
210 IF(N.EQ.0)GO TO 16
C N=0 MEANS T= NUM OF LINES DESIRED.
111 FORMAT(50I)
110 REREAD 111,NBAR
911 DO 112 K=50,1,-1
KP=NBAR(K)
KA=KA+KP
112 IF(KP.EQ.0.AND.KA.EQ.0)KL=K
IF(KA.NE.KT)GO TO 605
C MISMATCH!
N=26-2*MOD(KL-1,12)
IF(N.EQ.26)N=0
C TO SPACE OUT STAVES VERTICALLY
11 SPG=10./MPG
C MPG=NUM OF BRACES PER PAGE.
C SPG IS SPACE TO BE SET ABOVE STAFF 0
CALL WRTPAG
END
CC SUBROUTINE MINMAX
CC COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
CC MIN=10000
CC MAX=0
CC DO 107 K=1,JT
CC NN=JRN(K)
CC IF(NN.LT.MIN)MIN=NN
CC107 IF(NN.GT.MAX)MAX=NN
CC END
CC SUBROUTINE STORE
CC COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)/NBAR/NBAR(1)
CC DIMENSION MB(1)
CC EQUIVALENCE (MB,JRN(1000))
CC DO 1 K=2,JT+1
CC1 MB(K)=NBAR(K)
CC END
SUBROUTINE BRJUGL(JT,JBAR,KT,NBAR,MBAR,JRN,PGTRN,JTRN)
COMMON /BRJ/JTOT,TRN
DIMENSION JBAR(1),NBAR(1),MBAR(1),JRN(1),PGTRN(1),JTRN(1)
NT=JT
L=0
KTOT=JTOT
KAV=JTOT/JT
LMIN=-1
LMAX=10000
LJ=0
NJ=0
LMM=-1
LDIF=10000
NBAR(1)=1
J=1
3 M=1
JAV=KTOT/NT
K=JBAR(J)
1 J=J+1
IF(J.GT.KT)GO TO 2
N=JBAR(J)
IF(K+N/2.GE.JAV)GO TO 2
M=M+1
K=K+N
GO TO 1
2 L=L+1
KTOT=KTOT-K
NT=NT-1
JRN(L)=K
NBAR(L+1)=J
IF(NT.GT.0)GO TO 3
5 MAX=0
MIN=10000
DO 7 L=1,JT
K=JRN(L)
IF(K.LE.MAX)GO TO 6
MAX=K
MX=L
6 IF(K.GE.MIN)GO TO 7
MIN=K
MN=L
7 CONTINUE
J=MAX-MIN
IF(MAX.GE.LMAX.AND.J.GE.LDIF)GO TO 9
IF(MIN.GT.LMIN)LMIN=MIN
IF(MAX.LT.LMAX)LMAX=MAX
IF(J.LT.LDIF)LDIF=J
CALL RLOOP(MBAR(2),NBAR(2),JT)
C SAVE NBAR INFO IN MBAR
IF(MX.LT.MN)GO TO 32
IF(MX.LE.1)GO TO 5
JJ=0
JM=-1
JK=1
23 K=NBAR(MX+JJ)-JJ
C NEXT RIPPLES THE BARS, FROM MAX TO MIN.
MM=JBAR(K)
JRN(MX)=JRN(MX)-MM
JMX=JM+MX
JRN(JMX)=JRN(JMX)+MM
NBAR(MX+JJ)=K+JK
MX=JMX
IF(JJ.NE.0)GO TO 223
IF(MX.GT.MN)GO TO 23
GO TO 5
223 IF(MX.LT.MN)GO TO 23
GO TO 5
32 JJ=1
JM=1
JK=0
GO TO 23
9 CALL GET
IDIF=10000
JJT=JT-1
104 CALL MNMX(IDIF)
108 DO 102 J=1,JJT
IF(JRN(J).LE.KAV)GO TO 102
C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
I=NBAR(J+1)-1
IF(I.EQ.NBAR(J))GO TO 102
C WE'RE DOWN TO ONE BAR
JJ=JRN(J)-JBAR(I)
C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
IF(JJ.LT.MIN)GO TO 102
KK=JRN(J+1)+JBAR(I)
IF(KK.GT.MAX)GO TO 103
C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
CALL MINMAX
105 JRN(J)=JJ
JRN(J+1)=KK
NBAR(J+1)=NBAR(J+1)-1
GO TO 104
103 IF(J.EQ.JJT)GO TO 102
NN=KK
DO 106 K=J+1,JJT
LL=NBAR(K+1)-1
C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
MM=NN-JBAR(LL)
IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 102
NN=JBAR(LL)+JRN(K+1)
106 IF(NN.LE.MAX)GO TO 105
102 CONTINUE
204 CALL MNMX(IDIF)
208 DO 202 J=JT,2,-1
IF(JRN(J).LE.KAV)GO TO 202
C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
I=NBAR(J)
IF(I-1.EQ.NBAR(J-1))GO TO 202
C WE'RE DOWN TO ONE BAR
JJ=JRN(J)-JBAR(I)
C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
IF(JJ.LT.MIN)GO TO 202
KK=JRN(J-1)+JBAR(I)
IF(KK.GT.MAX)GO TO 203
C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
CALL MINMAX
205 JRN(J)=JJ
JRN(J-1)=KK
NBAR(J)=NBAR(J)+1
GO TO 204
203 IF(J.EQ.2)GO TO 202
NN=KK
DO 206 K=J-1,2,-1
LL=NBAR(K)
C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
MM=NN-JBAR(LL)
IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 202
NN=JBAR(LL)+JRN(K-1)
206 IF(NN.LE.MAX)GO TO 205
202 CONTINUE
CALL MINMAX
IDIF=MAX-MIN
CALL RLOOP(MBAR(2),NBAR(2),JT)
400 MX=MAX+5
JR=1
C JR = HOW MANY BARS TO RIPPLE
I=MAX-MIN
IF(I.GT.IDIF)GO TO 402
CALL RLOOP(MBAR(2),NBAR(2),JT)
IDIF=I
402 DO 401 J=1,JT
401 IF(JRN(J).EQ.MIN)GO TO 408
C TRY RIPPLE EACH WAY FROM SMALLEST VALUE
408 IF(J.EQ.JT)GO TO 508
C RIPPLE FORWARD FIRST
I=NBAR(J+1)
JJ=JRN(J)+JBAR(I)
IF(JJ.GT.MX)GO TO 508
C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
NN=JRN(J+1)-JBAR(I)
IF(NN.LT.MIN)GO TO 404
C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
JRN(J)=JJ
JRN(J+1)=NN
NBAR(J+1)=I+1
415 CALL MINMAX
C NOW GO BACK AND TRY AGAIN.
GO TO 400
405 JRN(J)=JJ
DO 422 IB=J+1,N
LB=NBAR(IB)
JB=JRN(IB)-JBAR(LB)
NBAR(IB)=LB+1
IF(JB.LT.MIN)GO TO 421
JRN(IB)=JB
GO TO 415
421 IBB=IB+1
LC=NBAR(IBB)
JB=JB+JBAR(LC)
IF(JB.GT.MIN)GO TO 422
C NOW ADD A SECOND BAR
JRN(IBB)=JRN(IBB)-JBAR(LC)
LC=LC+1
JB=JB+JBAR(LC)
NBAR(IBB)=LC
422 JRN(IB)=JB
NBAR(IBB)=LC+1
JRN(IBB)=JRN(IBB)-JBAR(LC)
GO TO 415
C NOW GO BACK AND TRY AGAIN.
404 IF(J.EQ.JJT)GO TO 508
DO 406 N=J+1,JJT
LL=NBAR(N+1)
MM=NN+JBAR(LL)
IF(MM.GT.MX)GO TO 508
IF(MM.GT.MIN)GO TO 409
C NEXT TO RIPPLE 2 BARS!
412 MN=MM+JBAR(LL+1)
C ADD ON A SECOND BAR
IF(MN.GT.MX)GO TO 508
C DON'T WORRY ABOUT IT BEING TOO SMALL (YET)
NN=JRN(N+1)-JBAR(LL)-JBAR(LL+1)
IF(NN.GT.MIN)GO TO 405
GO TO 406
409 NN=JRN(N+1)-JBAR(LL)
IF(NN.GE.MIN)GO TO 405
406 CONTINUE
C TRY RIPPLE EACH WAY FROM SMALLEST VALUE
508 IF(J.EQ.1)GO TO 502
IF(J.EQ.LJ.AND.MX-MN.EQ.LMM)GO TO 502
IF(JDIF.EQ.IDIF)GO TO 150
ICNT=0
GO TO 151
150 ICNT=ICNT+1
IF(ICNT.EQ.10)GO TO 515
151 JDIF=IDIF
C THIS SHOULD AVOID GETTING INTO A LOOP
LJ=J
LMM=MX-MN
C RIPPLE BACK NOW
I=NBAR(J)-1
JJ=JRN(J)+JBAR(I)
IF(JJ.GT.MX)GO TO 502
C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
NN=JRN(J-1)-JBAR(I)
IF(NN.LT.MIN)GO TO 504
C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
JRN(J)=JJ
JRN(J-1)=NN
NBAR(J)=I
GO TO 415
505 JRN(J)=JJ
DO 522 IB=J-1,N,-1
LB=NBAR(IB+1)-1
JB=JRN(IB)-JBAR(LB)
NBAR(IB+1)=LB
IF(JB.LT.MIN)GO TO 521
JRN(IB)=JB
GO TO 415
521 IBB=IB-1
LC=NBAR(IB)-1
JB=JB+JBAR(LC)
IF(JB.GT.MIN)GO TO 522
JB=JB+JBAR(LC-1)
NBAR(IB)=LC
JRN(IBB)=JRN(IBB)-JBAR(LC)
CHECK THIS OUT!!
LC=LC-1
522 JRN(IB)=JB
JRN(IBB)=JRN(IBB)-JBAR(LC)
NBAR(IB)=LC
GO TO 415
504 IF(J.LE.2)GO TO 502
DO 506 N=J-1,2,-1
LL=NBAR(N)-1
MM=NN+JBAR(LL)
IF(MM.GT.MX)GO TO 502
IF(MM.GT.MIN)GO TO 509
512 MN=MM+JBAR(LL-1)
IF(MN.GT.MX)GO TO 502
NN=JRN(N-1)-JBAR(LL)-JBAR(LL-1)
IF(NN.GT.MIN)GO TO 505
GO TO 506
509 NN=JRN(N-1)-JBAR(LL)
IF(NN.GE.MIN)GO TO 505
506 CONTINUE
502 IF(J.EQ.NJ.AND.MX-MN.EQ.LMM)GO TO 515
C CHECK TO AVOID ENDLESS LOOP.
NJ=J
IF(J.EQ.JT)GO TO 515
C LOOK FOR OTHER LINES = MIN.
DO 510 K=J+1,JT
IF(JRN(K).NE.MIN)GO TO 510
J=K
GO TO 408
510 CONTINUE
515 CALL GET
13 DO 14 L=2,JT
K=NBAR(L)
MM=JRN(L)
KK=JRN(L-1)
IF(MM.GE.KK)GO TO 12
C JUGGLES ADJACENT LINES
N=JBAR(K-1)
IF(KK-MM.LT.N)GO TO 14
JRN(L-1)=KK-N
JRN(L)=MM+N
NBAR(L)=K-1
GO TO 13
12 N=JBAR(K)
IF(MM-KK.LE.N)GO TO 14
JRN(L-1)=KK+N
JRN(L)=MM-N
NBAR(L)=K+1
GO TO 13
14 CONTINUE
46 J=1
NBAR(JT+1)=KT+1
JAV=JTOT/JT
CALL MINMAX
308 FORMAT(' AVG=',I3,' MIN=',I3,' MAX=',I3)
306 FORMAT(I5,3X8I5)
TYPE 308,JAV,MIN,MAX
IF(DSK)WRITE(21,308)JAV,MIN,MAX
307 DO 310 K=1,KT
L=JBAR(K)
IF(PGTRN(K).GE.TRN)L=-L
310 JTRN(K)=L
C ABOVE MAKES NEG. BAR VALUES WHERE TURNS ARE POSSIBLE.
309 DO 305 K=1,JT
NBAR(K)=NBAR(K+1)-NBAR(K)
C NBAR NOW HAS NUM. OF BARS PER LINE.
L=NBAR(K)-1+J
TYPE 306,JRN(K),(JTRN(N),N=J,L)
IF(DSK)WRITE(21,306)JRN(K),(JTRN(N),N=J,L)
305 J=L+1
END
SUBROUTINE GET
COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)/NBAR/NBAR(1)/KBAR/KBAR(1)
DIMENSION MB(1),JBAR(1)
EQUIVALENCE (MB,JRN(1000)),(JBAR,KBAR(4))
J=1
DO 1 K=2,JT+1
NBAR(K)=MB(K)
N=0
DO 2 L=J,MB(K)-1
C FIX UP JRN ARRAY
2 N=N+JBAR(L)
JRN(K-1)=N
1 J=MB(K)
END
CC SUBROUTINE MNMX(IDIF)
CC COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
CC L=MIN
CC N=MAX
CC CALL MINMAX
CC J=MAX-MIN
CC IF(J.LE.IDIF)GO TO 1
CC MIN=L
CC MAX=N
CC RETURN
CC1 IDIF=J
CC END